home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / imagelib / bimage.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  8KB  |  310 lines
  1. {Part of Imagelib VCL/DLL Library.
  2.  
  3. Written by Jan Dekkers and Kevin Adams}
  4.  
  5.  
  6.  
  7. unit Bimage;
  8.  
  9. interface
  10.  
  11. uses
  12.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  13.   Forms, Dialogs, StdCtrls, FileCtrl, TMULTI, VBXCtrl, Switch, Spin,
  14.   Buttons, BFullscr, Menus, Babout;
  15.  
  16. type
  17.   TForm1 = class(TForm)
  18.     DriveComboBox1: TDriveComboBox;
  19.     DirectoryListBox1: TDirectoryListBox;
  20.     FileListBox1: TFileListBox;
  21.     MultiImage1: TMultiImage;
  22.     Convert: TBitBtn;
  23.     QualitySpin: TSpinEdit;
  24.     Smoothspin: TSpinEdit;
  25.     QualityLabel: TLabel;
  26.     SmoothLabel: TLabel;
  27.     GroupBox1: TGroupBox;
  28.     res4: TRadioButton;
  29.     res24: TRadioButton;
  30.     res8: TRadioButton;
  31.     GroupBox2: TGroupBox;
  32.     Label5: TLabel;
  33.     Label6: TLabel;
  34.     Label7: TLabel;
  35.     DitherOneNo: TRadioButton;
  36.     DitherOneYes: TRadioButton;
  37.     DitherTwoNo: TRadioButton;
  38.     DitherTwoYes: TRadioButton;
  39.     Dither24Bit: TRadioButton;
  40.     MainMenu1: TMainMenu;
  41.     N1: TMenuItem;
  42.     E1: TMenuItem;
  43.     A1: TMenuItem;
  44.     ComboBox1: TComboBox;
  45.     Sstretch: TCheckBox;
  46.     GroupBox3: TGroupBox;
  47.     CTOJPEG: TRadioButton;
  48.     CTOBMP: TRadioButton;
  49.     Label1: TLabel;
  50.     FileListBox2: TFileListBox;
  51.     DirectoryListBox2: TDirectoryListBox;
  52.     DriveComboBox2: TDriveComboBox;
  53.     Label2: TLabel;
  54.     Label3: TLabel;
  55.     Label4: TLabel;
  56.     procedure DriveComboBox1Change(Sender: TObject);
  57.     procedure DirectoryListBox1Change(Sender: TObject);
  58.     procedure FileListBox1Change(Sender: TObject);
  59.     procedure SstretchOnOff(Sender: TObject);
  60.     procedure FormCreate(Sender: TObject);
  61.     procedure resClick(Sender: TObject);
  62.     procedure DitherClick(Sender: TObject);
  63.     procedure MultiImage1Click(Sender: TObject);
  64.     procedure E1Click(Sender: TObject);
  65.     procedure A1Click(Sender: TObject);
  66.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  67.     procedure ComboBox1Change(Sender: TObject);
  68.     procedure ConvertClick(Sender: TObject);
  69.     procedure DirectoryListBox2Change(Sender: TObject);
  70.     procedure DriveComboBox2Change(Sender: TObject);
  71.     procedure FileListBox2Change(Sender: TObject);
  72.     procedure QualitySpinChange(Sender: TObject);
  73.     procedure SmoothspinChange(Sender: TObject);
  74.   private
  75.     function NameOnly(PName : string) : string;
  76.   public
  77.     { Public declarations }
  78.   end;
  79.  
  80. var
  81.   Form1: TForm1;
  82.  
  83. implementation
  84.  
  85. {$R *.DFM}
  86.  
  87. {update the drive of DirectoryListBox1 with the drive of DriveComboBox1}
  88. procedure TForm1.DriveComboBox1Change(Sender: TObject);
  89. begin
  90.   DirectoryListBox1.Drive := DriveComboBox1.Drive;
  91. end;
  92.  
  93. {update the directory of FileListBox1 with the directory of FileListBox1}
  94. procedure TForm1.DirectoryListBox1Change(Sender: TObject);
  95. begin
  96.        FileListBox1.Directory := DirectoryListBox1.Directory;
  97. end;
  98.  
  99. {Display the image of the FileListBox1.filename}
  100. procedure TForm1.FileListBox1Change(Sender: TObject);
  101. begin
  102.  {set hourglass cursor}
  103.   screen.cursor:=crHourGlass;
  104.  try
  105.  {display an image using the vcl}
  106.   MultiImage1.imagename:=FileListBox1.filename;
  107.  finally
  108.   {set default cursor}
  109.   screen.cursor:=crDefault;
  110.  end;
  111. end;
  112.  
  113. procedure TForm1.FileListBox2Change(Sender: TObject);
  114. begin
  115.  {set hourglass cursor}
  116.   screen.cursor:=crHourGlass;
  117.  try
  118.  {display an image using the vcl}
  119.   MultiImage1.imagename:=FileListBox2.filename;
  120.  finally
  121.   {set default cursor}
  122.   screen.cursor:=crDefault;
  123.  end;
  124. end;
  125.  
  126. {set strech mode}
  127. procedure TForm1.SstretchOnOff(Sender: TObject);
  128. begin
  129.   MultiImage1.stretch:=Sstretch.Checked;
  130. end;
  131.  
  132.  
  133. {what we do on create}
  134. procedure TForm1.FormCreate(Sender: TObject);
  135. begin
  136.     {set the value of the QualitySpin to the value of JPegSaveQuality}
  137.     QualitySpin.value:=MultiImage1.JPegSaveQuality;
  138.  
  139.     {set the value of the Smoothspin to the value of JPegSaveSmooh}
  140.     Smoothspin.value:=MultiImage1.JPegSaveSmooth;
  141.  
  142. end;
  143.  
  144. {Set the jpeg resolution to either 16, 256 or true color in the vcl}
  145. procedure TForm1.resClick(Sender: TObject);
  146. begin
  147.  {set jpeg show resolution to 4 bit 16 color}
  148.  if res4.checked  then MultiImage1.JPegResolution:=4;
  149.  
  150.  {set jpeg show resolution to 8 bit 256 color}
  151.  if res8.checked  then MultiImage1.JPegResolution:=8;
  152.  
  153.  {set jpeg show resolution to 24 bit true color}
  154.  if res24.checked then MultiImage1.JPegResolution:=24;
  155. end;
  156.  
  157.  
  158. {Set the jpeg dither in the vcl}
  159. procedure TForm1.DitherClick(Sender: TObject);
  160. begin
  161.   {set the jpeg show dither to none (best choice for true color 24 bit}
  162.   if Dither24Bit.checked  then MultiImage1.JPegDither:=0;
  163.  
  164.   {set the jpeg show dither to one pass none}
  165.   if DitherOneNo.checked  then MultiImage1.JPegDither:=1;
  166.  
  167.   {set the jpeg show dither to one pass dithered (best choice for 16 colors)}
  168.   if DitherOneYes.checked  then MultiImage1.JPegDither:=2;
  169.  
  170.   {set the jpeg show dither to one pass none}
  171.   if DitherTwoNo.checked  then MultiImage1.JPegDither:=3;
  172.  
  173.   {set the jpeg show dither to two pass dithered (best choice for 256 colors)}
  174.   if DitherTwoYes.checked  then MultiImage1.JPegDither:=4;
  175. end;
  176.  
  177.  
  178. {show fullscreen}
  179. procedure TForm1.MultiImage1Click(Sender: TObject);
  180. begin
  181.   {copy image to fullscreen image}
  182.   FullSlide.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  183.   {show the image fulscreen}
  184.   FullSlide.showmodal;
  185. end;
  186.  
  187. {exit the program}
  188. procedure TForm1.E1Click(Sender: TObject);
  189. begin
  190.  close;
  191. end;
  192.  
  193. {about box}
  194. procedure TForm1.A1Click(Sender: TObject);
  195. begin
  196. {Copy the image to the image of he about box}
  197.  AboutBox.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  198. {show the about box}
  199.  AboutBox.showmodal;
  200. end;
  201.  
  202. {what to do on exit}
  203. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  204. begin
  205. {}
  206. end;
  207.  
  208. procedure TForm1.ComboBox1Change(Sender: TObject);
  209. begin
  210.  FileListBox1.Mask:=ComboBox1.text;
  211.  FileListBox1.Update;
  212. end;
  213.  
  214.  
  215. {return filename only. no path, no extension}
  216. function TForm1.NameOnly(PName : string) : string;
  217.  var
  218.    DtP : Byte;
  219.  
  220.  function JName(PName : string) : string;
  221.   var
  222.     I : Word;
  223.   const
  224.     DDSet : set of Char = ['\', ':', #0];
  225.   begin
  226.     I := Succ(Word(Length(PName)));
  227.     repeat
  228.       Dec(I);
  229.     until (PName[I] in DDSet) or (I = 0);
  230.     JName := Copy(PName, Succ(I), 64);
  231.   end;
  232.  
  233.   begin
  234.     PName := JName(PName);
  235.     DtP := Pos('.', PName);
  236.     if DtP > 0 then
  237.       PName := Copy(PName, 1, DtP-1);
  238.     NameOnly := PName;
  239.   end;
  240.  
  241.  
  242.  
  243. {The actual conversion}
  244. procedure TForm1.ConvertClick(Sender: TObject);
  245. var i          : integer;
  246.     pTempExt   : string[4];
  247.     pExtension : string[4];
  248.     pName      : string[13];
  249.     pPath      : string[100];
  250.     toTemp      : string;
  251.     frTemp      : string;
  252. begin
  253.  Label3.CapTion:='';
  254.  
  255.  if CTOJPEG.Checked then
  256.     pTempExt:='.JPG'
  257.  else
  258.     pTempExt:='.BMP';
  259.  
  260.  for i:=0 to FileListBox1.items.count-1 do begin
  261.      if FileListBox1.Selected[i] then begin
  262.  
  263.        pExtension:=UpperCase(ExtractFileExt(FileListBox1.Items.Strings[i]));
  264.        pName:=UpperCase(NameOnly(FileListBox1.Items.Strings[i]));
  265.        pPath:=UpperCase(DirectoryListBox2.Directory);
  266.  
  267.        toTemp:=pPath+'\'+pName+pTempExt;
  268.        frTemp:=UpperCase(DirectoryListBox1.Directory+'\'+FileListBox1.Items.Strings[i]);
  269.        {set hourglass cursor}
  270.         screen.cursor:=crHourGlass;
  271. try
  272.        if CTOJPEG.Checked then begin
  273.         MultiImage1.imagename:=frTemp;
  274.         MultiImage1.SaveAsJpg(toTemp)
  275.        end else begin
  276.         MultiImage1.imagename:=frTemp;
  277.         MultiImage1.Picture.SaveToFile(toTemp);
  278.        end;
  279. finally
  280.       {set default cursor}
  281.       screen.cursor:=crDefault;
  282.       FileListBox2.UpDate;
  283. end;
  284.       end;
  285.       Label3.CapTion:='DONE';
  286.  end;
  287. end;
  288.  
  289. procedure TForm1.DirectoryListBox2Change(Sender: TObject);
  290. begin
  291.   FileListBox2.Directory := DirectoryListBox2.Directory;
  292. end;
  293.  
  294. procedure TForm1.DriveComboBox2Change(Sender: TObject);
  295. begin
  296.   DirectoryListBox2.Drive := DriveComboBox2.Drive;
  297. end;
  298.  
  299. procedure TForm1.QualitySpinChange(Sender: TObject);
  300. begin
  301.   MultiImage1.JpegSaveQuality:=QualitySpin.Value;
  302. end;
  303.  
  304. procedure TForm1.SmoothspinChange(Sender: TObject);
  305. begin
  306.   MultiImage1.JpegSaveSmooth:=Smoothspin.Value;
  307. end;
  308.  
  309. end.
  310.